home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / trid.zip / 3DEMO.PAS next >
Pascal/Delphi Source File  |  1993-01-04  |  13KB  |  406 lines
  1. {   A three dimensional graphics demonstration program     }
  2. {   Written 2/11/1988 by Gus Smedstad                      }
  3. {   3-d primitives provided by TRI_D.TPU, by Gus Smedstad  }
  4. {$N-}
  5. uses Crt, graph, tri_d;
  6.  
  7. const tablemax = 12;  { Maximum number of color/pattern combinations needed }
  8. type  ObjInfo = record
  9.                  Name  : String[10];  { name of object }
  10.                  center: vector;      { center point for rotation }
  11.                  data  : pointer;     { Tri_D information }
  12.                 end;
  13.  
  14.  
  15. var colortable : array[1..tablemax] of FillSettingsType;
  16.                   { Table to provide 'generic' colors for all monitors }
  17.     Object     : array[0..5] of ObjInfo;
  18.                   { Objects.  Global for simplicity. }
  19.     paging     : boolean;          { True if graphics card supports paging }
  20.  
  21. procedure ChangeColor(front, back : integer);
  22. begin
  23.   SetPolyColors(colortable[front].pattern, colortable[front].color,
  24.                 colortable[back].pattern, colortable[back].color)
  25.  end;
  26.  
  27.  
  28. { -----  Routines to draw the five objects  ----- }
  29.  
  30. procedure Ring(x,y,z, radius : real; step : integer);  { draw a cylinder }
  31. var cosine : array[0..20] of real;
  32.     sine   : array[0..20] of real;
  33.     i      : integer;
  34.     p      : array[1..4] of vector;
  35. begin
  36.   ChangeColor(1,2);
  37.   for i := 0 to step do begin
  38.     cosine[i] := cos(i * 2 * pi / step);
  39.     sine[i] := sin(i * 2 * pi / step);
  40.    end;
  41.   for i := 1 to step do begin
  42.     p[1][0] := radius * cosine[i-1] + x;
  43.     p[1][1] := radius * sine[i-1] + y;
  44.     p[1][2] := z;
  45.     p[2][0] := radius * cosine[i] + x;
  46.     p[2][1] := radius * sine[i] + y;
  47.     p[2][2] := z;
  48.     p[3] := p[2];
  49.     p[3][2] := radius * 2 + z;
  50.     p[4] := p[1];
  51.     p[4][2] := radius * 2 + z;
  52.     MakePolygon(p,4);
  53.    end
  54.  end;
  55.  
  56. procedure Hemisphere(x, y, z, radius : real; step : integer);
  57. var cosine : array[0..30] of real;
  58.     sine   : array[0..30] of real;
  59.     i, j   : integer;
  60.     F, H   : real;
  61.     oldH   : real;
  62.     oldF   : real;
  63.     p      : array[1..4] of vector;
  64. begin
  65.   ChangeColor(3,4);
  66.   step := step * 2;
  67.   for i := 0 to step do begin
  68.     cosine[i] := cos(i * 2 * pi / step);
  69.     sine[i] := sin(i * 2 * pi / step);
  70.    end;
  71.   F := 0;
  72.   H := radius;
  73.   for i := 1 to (step div 2) do begin
  74.     oldF := F;
  75.     oldH := H;
  76.     F := radius * sin(i * pi / step);
  77.     H := radius * cos(i * pi / step);
  78.     for j := 1 to step do begin
  79.       p[1][0] := oldF * cosine[j-1] + x;
  80.       p[1][1] := oldH + y;
  81.       p[1][2] := oldF * sine[j-1] + z;
  82.       p[2][0] := F * cosine[j-1] + x;
  83.       p[2][1] := H + y;
  84.       p[2][2] := F * sine[j-1] + z;
  85.       p[3][0] := F * cosine[j] + x;
  86.       P[3][1] := H + y;
  87.       p[3][2] := F * sine[j] + z;
  88.       p[4][0] := oldF * cosine[j] + x;
  89.       p[4][1] := oldH + y;
  90.       p[4][2] := oldF * sine[j] + z;
  91.       MakePolygon(p,4)
  92.      end
  93.    end
  94.  end;
  95.  
  96. procedure House(x,y,z, size : real);
  97. var front,
  98.     back : array[0..4] of vector;
  99.     side : array[0..3] of vector;
  100.     i, l: integer;
  101. begin
  102.   back[0,0] := -size; back[0,1] := 0;      back[0,2] := -size;
  103.   back[1,0] := size;  back[1,1] := 0;      back[1,2] := -size;
  104.   back[2,0] := size;  back[2,1] := size/2; back[2,2] := -size;
  105.   back[3,0] := 0;     back[3,1] := size;   back[3,2] := -size;
  106.   back[4,0] := -size; back[4,1] := size/2; back[4,2] := -size;
  107.   for i := 0 to 4 do begin
  108.     back[i,0] := back[i,0] + x;
  109.     back[i,1] := back[i,1] + y;
  110.     back[i,2] := back[i,2] + z;
  111.    end;
  112.   for i := 0 to 4 do begin
  113.     front[i][0] := back[i][0];
  114.     front[i][1] := back[i][1];
  115.     front[i][2] := back[i][2] + size * 2;
  116.    end;
  117.   l := 4;
  118.   ChangeColor(5,5);
  119.   for i := 0 to 4 do begin
  120.     side[0] := back[l];
  121.     side[1] := back[i];
  122.     side[2] := front[i];
  123.     side[3] := front[l];
  124.     MakePolygon(side,4);
  125.     l := i;
  126.    end;
  127.   ChangeColor(6,6);
  128.   MakePolygon(back,5);
  129.   MakePolygon(front,5);
  130.  end;
  131.  
  132. procedure Rect(x, y1, z1, y2, z2 : real);
  133. var p : array[1..4] of vector;
  134. begin
  135.   p[1][0] := x;  p[1][1] := y1;  p[1][2] := z1;
  136.   p[2][0] := x;  p[2][1] := y2;  p[2][2] := z1;
  137.   p[3][0] := x;  p[3][1] := y2;  p[3][2] := z2;
  138.   p[4][0] := x;  p[4][1] := y1;  p[4][2] := z2;
  139.   ChangeColor(7,8);
  140.   MakePolygon(p,4);
  141.  end;
  142.  
  143. procedure Pyramid(x,y,z, scale : real);
  144. var bottom : array[1..4] of vector;
  145.     tip    : vector;
  146.     old    : vector;
  147.     i      : integer;
  148. begin
  149.   bottom[1][0] := x+scale/2;  bottom[1][1] := y; bottom[1][2] := z-scale/2;
  150.   bottom[2][0] := x+scale/2;  bottom[2][1] := y; bottom[2][2] := z+scale/2;
  151.   bottom[3][0] := x-scale/2;  bottom[3][1] := y; bottom[3][2] := z+scale/2;
  152.   bottom[4][0] := x-scale/2;  bottom[4][1] := y; bottom[4][2] := z-scale/2;
  153.   ChangeColor(9,9);
  154.   MakePolygon(bottom,4);
  155.   tip[0] := x;  tip[1] := y+scale;  tip[2] := z;
  156.   old := bottom[4];
  157.   for i := 1 to 4 do begin
  158.     ChangeColor((i mod 2) + 10,(i mod 2) + 10);
  159.     MakeTriangle(old,tip,bottom[i]);
  160.     old := bottom[i]
  161.    end
  162.  end;
  163.  
  164.  
  165. { ----- Initialize graphics card, create color table, create objects -----}
  166.  
  167. procedure CreateObjects;
  168. const Zero : vector = (0,0,0);
  169. var i : integer;
  170. begin
  171.   SetLineStyle(SolidLn,0,1);
  172.   with Object[0] do begin
  173.     center[0] := 0;
  174.     center[1] := 0;
  175.     center[2] := 30;
  176.     name := 'Viewpoint';
  177.     SetViewPoint(center[0],center[1],center[2]);
  178.    end;
  179.   SetViewDirection(0,0,0);
  180.   with Object[1] do begin
  181.     MakeObject(data);
  182.     Ring(-7,7,0,3,12);
  183.     center[0] := -7; center[1] := 7; center[2] := 0;
  184.     name := 'Cylinder';
  185.    end;
  186.   with Object[2] do begin
  187.     MakeObject(data);
  188.     Hemisphere(7,7,0,6,8);
  189.     center[0] := 7; center[1] := 7; center[2] := 0;
  190.     name := 'Hemisphere';
  191.    end;
  192.   with Object[3] do begin
  193.     MakeObject(data);
  194.     Pyramid(-15,-7,0,7);
  195.     center[0] := -15; center[1] := -7; center[2] := 0;
  196.     name := 'Pyramid';
  197.    end;
  198.   with Object[4] do begin
  199.     MakeObject(data);
  200.     House(0,-7,0,4);
  201.     Center[0] := 0; center[1] := -7; center[2] := 0;
  202.     name := 'House';
  203.    end;
  204.   with Object[5] do begin
  205.     MakeObject(data);
  206.     Rect(15,-12,4,-3,-4);
  207.     Center[0] := 15;  Center[1] := -7; Center[2] := 0;
  208.     name := 'Plane';
  209.    end;
  210.   CloseObject;   { We're finished making objects }
  211.  end;
  212.  
  213. procedure Init;
  214. var colormax : integer;
  215.     c, s, i  : integer;
  216.     GraphDriver, GraphMode : integer;
  217. begin
  218.   GraphDriver := Detect;
  219.   InitGraph(GraphDriver, GraphMode, '');
  220.   if GraphResult <> grOK then begin
  221.     Writeln('Graphics initialization error: ', GraphErrorMsg(GraphDriver));
  222.     Halt(1);
  223.    end;
  224.   SetViewPort(0,TextHeight(' ')*2 + 4,GetmaxX,GetmaxY,True);
  225.   paging := (GraphDriver = HercMono) or (GraphDriver = EGA) or
  226.             (GraphDriver = EGA64)    or (GraphDriver = VGA);
  227.   c := 1;
  228.   s := SolidFill;
  229.   colormax := GetMaxColor;
  230.   for i := 1 to TableMax do begin   { cycle through colors and fill styles }
  231.     Colortable[i].pattern := s;
  232.     Colortable[i].color := c;
  233.     c := succ(c);
  234.     if C > colormax then begin
  235.       c := 1;
  236.       s := s + 1;
  237.       if s = UserFill then s := SolidFill
  238.      end
  239.    end;
  240.   SetScale(2);
  241.   SetCenter(GetmaxX div 2, GetmaxY div 2);
  242.   CreateObjects;
  243.  end;
  244.  
  245. { Show the menu at the top of the screen }
  246. procedure showmenu(o : integer; rot: boolean);
  247. begin
  248.   SetViewPort(0,0,GetmaxX,TextHeight(' ')*2 + 4,False);
  249.   ClearViewport;
  250.   SetColor(GetMaxColor);
  251.   OuttextXY(0,0,
  252.    ' 1-5 object  Rotate  Move  Viewpoint  Hide edges  Clear  Quit');
  253.   Moveto(0,TextHeight(' '));
  254.   if rot then Outtext('Rotate ') else Outtext('Move ');
  255.   Outtext(Object[o].Name);
  256.   Outtext('  Dir: <arrow keys> <page up>: add Z  <page down>: subtract Z');
  257.   SetViewPort(0,TextHeight(' ')*2 + 4,GetmaxX,GetmaxY,True);
  258.  end;
  259.  
  260. { --- Move an object or the viewpoint by dx, dy, and dz --- }
  261. procedure MoveOb(obj : integer; dx, dy, dz : real);
  262. begin
  263.   with object[obj] do begin
  264.     center[0] := center[0] + dx;            { We're keeping track of this }
  265.     center[1] := center[1] + dy;            { so we know what point to    }
  266.     center[2] := center[2] + dz;            { rotate the object about.    }
  267.     if obj > 0 then
  268.       MoveObject(data,dx,dy,dz)
  269.      else
  270.       SetViewPoint(center[0],center[1],center[2]);
  271.    end
  272.  end;
  273.  
  274. procedure RotOb(obj : integer; ThetaX, ThetaY, ThetaZ : real);
  275. var Theta : vector;
  276.     delta : vector;
  277.     i     : integer;
  278. begin
  279.   if obj = 0 then
  280.     RotateViewDirection(-ThetaX, ThetaY, -ThetaZ)
  281.    else begin
  282.      { We don't want to move it, just rotate. }
  283.     for i := 0 to 2 do delta[i] := 0;
  284.     Theta[0] := ThetaX;
  285.     Theta[1] := ThetaY;
  286.     Theta[2] := ThetaZ;
  287.     with object[obj] do RotateObject(data,Theta,Center,delta);
  288.    end
  289.  end;   { That's all there is to it. }
  290.  
  291.  
  292. procedure ResetData;
  293. var i : integer;
  294. begin
  295.   CloseObject;
  296.   for i := 1 to 5 do with Object[i] do DeleteObject(Data);
  297.   ClearDevice;
  298.   CreateObjects;
  299.  end;
  300.  
  301. var ch       : char;     { Holds last keypress }
  302.     obj      : integer;  { Current object # }
  303.     angle    : real;     { increment for rotations }
  304.     NewMenu  : boolean;  { Do we need to change the menu? }
  305.     EraseScr : boolean;  { Do we need to erase the screen ? }
  306.     rot      : boolean;  { Are we rotating or moving objects? }
  307.     done     : boolean;
  308.     Page     : integer;
  309.     i        : integer;
  310. begin
  311.   Init;
  312.   angle := pi/10;   { Set the increment for rotations }
  313.   obj := 0;         { start with the viewpoint}
  314.   page := 0;
  315.   rot := false;
  316.   done := false;
  317.   NewMenu := True;
  318.   repeat            { Main loop - repeat until we're bored }
  319.     if NewMenu then ShowMenu(obj, rot);
  320.     EraseScr := False;
  321.     NewMenu := False;
  322.     Ch := Readkey;
  323.     if ch = #0 then begin  { Special key - presumed to be an arrow key. }
  324.       if (obj > 0) then
  325.         EraseObject(Object[obj].data)
  326.        else
  327.         EraseScr := true;  { If we're moving the viewpoint, we need a new }
  328.                            { screen }
  329.       case ord(readkey) of
  330.         $48 : if rot then                 { Up arrow }
  331.                 RotOb(obj,-angle,0,0)
  332.                else
  333.                 MoveOb(obj,0,1,0);
  334.         $49 : MoveOb(obj,0,0,-1);         { page up }
  335.         $4b : if rot then                 { Left arrow }
  336.                 RotOb(obj,0,-angle,0)
  337.                else
  338.                 MoveOb(obj,-1,0,0);
  339.         $4d : if rot then                 { Right Arrow }
  340.                 RotOb(obj,0,angle,0)
  341.                else
  342.                 MoveOb(obj,1,0,0);
  343.         $50 : if rot then                 { down arrow }
  344.                 RotOb(obj,angle,0,0)
  345.                else
  346.                 MoveOb(obj,0,-1,0);
  347.         $51 : MoveOb(obj,0,0,1);          { page down }
  348.        end;
  349.       if Obj > 0 then DrawObject(object[obj].data);
  350.      end
  351.      else begin
  352.       NewMenu := True;   { All of these change the menu }
  353.       case upcase(ch) of
  354.        '1'..'5' : begin
  355.                    if obj > 0 then with Object[obj] do begin
  356.                      ObjectStyle(data,SolidLn,0,1);   { Redraw the previous }
  357.                      DrawObject(data);                { selection }
  358.                     end;
  359.                    obj := ord(ch) - ord('0');   { set object }
  360.                    with Object[obj] do begin
  361.                      EraseObject(data);             { Redraw it with dashes }
  362.                      ObjectStyle(data,DashedLn,0,1);
  363.                      DrawObject(data)
  364.                     end;
  365.                   end;
  366.        'V'      : begin
  367.                    if obj > 0 then with object[obj] do begin
  368.                      ObjectStyle(data,SolidLn,0,1);  { Redraw the previous }
  369.                      DrawObject(data)                { selection }
  370.                     end;
  371.                    obj := 0;
  372.                   end;
  373.        'M'      : rot := false;
  374.        'R'      : rot := True;
  375.        'C'      : begin
  376.                     EraseScr := True;
  377.                     ResetData;
  378.                     obj := 0;
  379.                    end;
  380.        #27, 'Q' : done := true;
  381.        'H'      : begin
  382.                    SetDrawMode(true,true);     { change to hidden-edges }
  383.                    Regenerate;                 { draw it }
  384.                    repeat until keypressed;    { wait for next key }
  385.                    EraseScr := true;           { those filled polygons }
  386.                    SetDrawMode(false,true);    { reset to wireframe }
  387.                   end;
  388.        end  { of Case upcase(ch) }
  389.      end;
  390.     if EraseScr then begin        { redraw the screen }
  391.       if paging then begin
  392.         SetVisualPage(page);      { if we've got pages, use other page. }
  393.         SetActivePage(1-page);
  394.        end;
  395.       NewMenu := True;
  396.       ClearDevice;
  397.       regenerate;
  398.       if paging then begin
  399.         SetVisualPage(1-page);    { Let 'em look at our finished image }
  400.         page := 1-page;           { Alternate pages }
  401.        end;
  402.      end
  403.    until done;
  404.   CloseGraph;
  405.  end.
  406.